Collection of Tools & Utilities/Collection of Tools and Utilities.iso/pascal/tptc17sc.zip/TPCSCAN.INC

Text File | 1988-03-26 | 20KB | 834 lines

(*
 * TPTC - Turbo Pascal to C translator
 *
 * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
 *
 *)


(********************************************************************)
(*
 * lexical scanner
 *
 *)

function numlit(n: integer): anystring;
var
   lit: string[6];

   {convert an integer into a c style numeric character literal}
   function digit(n: integer): char;
      (* convert an integer into a hex digit *)
   begin
      n := n and 15;
      if n > 9 then n := n + 7;
      digit := chr( n + ord('0') );
   end;

begin
   lit := '''\?''';

   case n of
     $07:   lit[3] := 'a';
     $08:   lit[3] := 'b';
     $09:   lit[3] := 't';
     $0a:   lit[3] := 'n';
     $0b:   lit[3] := 'v';
     $0c:   lit[3] := 'f';
     $0d:   lit[3] := 'r';

     32..126,128..254:
            lit := ''''+chr(n)+'''';

     else   begin
               lit := '''\x??''';
               lit[4] := digit(n shr 4);
               lit[5] := digit(n);
            end;
   end;

   numlit := lit;
   toktype := chars;
end;


(********************************************************************)
procedure getchar;
   {consume the current char and get the next one}
var
   stack: char;
begin
   if ofs(stack) < minstack then
      fatal('Out of stack space');

   while (srclevel > 0) and eof(srcfd[srclevel]) do
   begin
      if not linestart then putline;
      putln('/* TPTC: end of '+srcfiles[srclevel]+' */');

      if debug then writeln;
      writeln(^M,srcfiles[srclevel],'(',srclines[srclevel],')');

      close(srcfd[srclevel]);
      freemem(inbuf[srclevel],inbufsiz);

      dec(srclevel);
      statustime := 0;
   end;

   if eof(srcfd[srclevel]) then
      nextc := '.'
   else
      read(srcfd[srclevel], nextc);

   if nextc = ^J then
   begin
      inc(srclines[srclevel]);
      inc(srctotal);

      mark_time(curtime);
      if (curtime >= statustime) or debug then
      begin
         if debug then writeln;
         write(^M,srcfiles[srclevel],'(',srclines[srclevel],')');
         statustime := curtime+statrate;
         abortcheck;
      end;
   end;
end;


(********************************************************************)
function usec: char;
   {use up the current character(return it) and get
    the next one from the input stream}
var
   c: char;
begin
   c := nextc;
   getchar;
   usec := c;
end;


(********************************************************************)
function newc(n: string40): string40;
   {replace the current character with a different one and get the next
    character from the input stream}
var
   c: char;
begin
   c := nextc;
   getchar;
   newc := n;
end;


(********************************************************************)
procedure concat_tokens;
   {concatenate the next token and the current token}
var
   cur: string;
begin
   cur := ltok;
   ltok := nextc;
   toktype := unknown;
   scan_tok;

   ltok := copy(cur,1,length(cur)-1) + copy(ltok,2,255);
   ltok[1] := '"';
   ltok[length(ltok)] := '"';
   toktype := strng;
end;


(********************************************************************)
procedure scan_ident;
   {scan an identifier; output is ltok; nextc is first character following
    the identifier; toktype = identifier;  this is the protocol for all of
    the scan_xxxx procedures in the lexical analyzer}
begin

   toktype := unknown;
   ltok := '';

   repeat
      case nextc of
         'A'..'Z':
            begin
               if map_lower then
                  nextc := chr( ord(nextc)+32 );
               ltok := ltok + nextc;
               getchar;
            end;

         'a'..'z', '0'..'9', '_','@':
            ltok := ltok + usec;

         else
            toktype := identifier;
      end;

   until toktype = identifier;
end;



(********************************************************************)
procedure scan_preproc;
   {scan a tshell preprocessor directive;  same syntax as C already}
begin
   puts('#');

   repeat
      puts(nextc);
      getchar;
   until nextc = ^M;

   getchar;
   putline;
   toktype := unknown;
end;


(********************************************************************)
procedure scan_number;
   {scan a number;  this also processes #nnn character literals, which are
    converted into octal character literals.  imbedded periods are processed,
    and a special condition is noted for trailing periods.  this is needed
    for scanning the ".." keyword when used after numbers.  an ungetchar
    facility would be more general, but isn't needed anywhere else.
    in pascal/mt+, #nnn is translated into nnnL }
var
   hasdot:  boolean;
   charlit:   boolean;
   islong:  boolean;

begin
   hasdot := false;
   islong := false;
   charlit := false;
   toktype := number;

(* check for preprocessor directives, character literals or long literals *)
   if nextc = '#' then
   begin
      ltok := '';
      if mt_plus then
         islong := true
      else
         charlit := true;
   end;

   getchar;

(* check for preprocessor directives *)
   if tshell and charlit and (nextc >= 'a') and (nextc <= 'z') then
      scan_preproc
   else

   repeat
      case nextc of
         '$','0'..'9','a'..'f','A'..'F':
            ltok := ltok + usec;

         '.':
            if hasdot then
            begin
               if ltok[length(ltok)] = '.' then
               begin
                  ltok[0] := pred(ltok[0]);  {remove trailing ., part of ..}
                  if charlit then
                     ltok := numlit(atoi(ltok));
                  extradot := true;
               end;
               exit;
            end
            else

            begin
               hasdot := true;
               ltok := ltok + usec;
            end;

         else
            begin
               if charlit then
               begin
                  ltok := numlit(atoi(ltok));
                  if (nextc = '''') or (nextc = '^') or (nextc = '#') then
                     concat_tokens;
                  exit;
               end;

               if ltok[1] = '$' then
                  ltok := '0x' + copy(ltok,2,99);
               if islong then
                  ltok := ltok + 'L';
               exit;
            end;
      end;

   until true=false;
end;


(********************************************************************)
procedure scan_hat;
   {scan tokens starting with ^ - returns ^X as a character literal
    corresponding to the specified control character.  returns ^ident as
    an identifier with the leading ^ intact.  also scans ^. and ^[.}
var
   c: char;

begin
   getchar;

   if ((nextc = '.') or (nextc = '[')) and
      ((ptoktype = identifier) or (ptok = ']')) then
   begin
      ltok := '^' + usec;     {^. or ^[}
      exit;
   end;

   case nextc of
      '@','['..'`':
         ltok := usec;

      'A'..'Z','a'..'z':
         begin
            ltok := nextc;
            scan_ident;
         end;
       else
         exit;
   end;

   if length(ltok) = 1 then      {^c = control char}
   begin
      ltok := numlit( ord(upcase(ltok[1])) - ord('@') );
      if (nextc = '''') or (nextc = '^') or (nextc = '#') then
         concat_tokens;
   end
   else
      ltok := '^' + ltok;        {^ident = pointer to ident}

end;


(********************************************************************)
procedure scan_dot;
   {scans tokens starting with "."; knows about the 'extra dot' condition
    that comes up in number scanning.  returns a token of either '.' or '..'}
begin
   getchar;

   if (nextc = '.') or extradot then
   begin
      ltok := '..';
      extradot := false;
   end;

   if nextc = '.' then
      getchar;
end;


(********************************************************************)
procedure scan_string;
   {scans a literal string.  processes imbedded quotes ala pascal.  translates
    the s